home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Camelot / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].zip / Camelot 098 (1990-12)(Swedish User Group of Amiga)(SE)(PD)[WB].adf / XLisp-Stat / Functions / tour.lsp < prev    next >
Lisp/Scheme  |  1990-10-11  |  3KB  |  76 lines
  1. ; book pp.323-328
  2.  
  3. (defproto tour-mixin '(tour-count tour-trans))
  4. (defmeth tour-mixin :do-idle () (send self :tour-step))
  5. (defmeth tour-mixin :tour-step ()
  6.   (when (< (slot-value 'tour-count) 0)
  7.         (flet ((sphere-rand (m)
  8.                  (let* ((x (normal-rand m))
  9.                         (nx2 (sum (^ x 2))))
  10.                     (if (< 0 nx2)
  11.                         (/ x (sqrt nx2))
  12.                         (/ (repeat 1 m) (sqrt m))))))
  13.           (let* ((m (send self :num-variables))
  14.                  (angle (send self :angle))
  15.                  (max (+ 1 (abs (floor (/ pi (* 2 angle)))))))
  16.             (setf (slot-value 'tour-count) (random max))
  17.             (setf (slot-value 'tour-trans)
  18.                   (make-rotation (sphere-rand m)
  19.                                  (sphere-rand m)
  20.                                  angle)))))
  21.   (send self :apply-transformation (slot-value 'tour-trans))
  22.   (setf (slot-value 'tour-count)
  23.         (- (slot-value 'tour-count) 1)))
  24. (send tour-mixin :slot-value 'tour-count -1)
  25. (defmeth tour-mixin :tour-on (&rest args)
  26.   (apply #'send self :idle-on args))
  27.  
  28. (defproto tour-item-proto '(graph) () menu-item-proto)
  29. (defmeth tour-item-proto :isnew (graph)
  30.   (call-next-method "Touring")
  31.   (setf (slot-value 'graph) graph))
  32. (defmeth tour-item-proto :graph () (slot-value 'graph))
  33. (defmeth tour-item-proto :update ()
  34.   (let ((graph (send self :graph)))
  35.     (send self :mark (send graph :tour-on))))
  36. (defmeth tour-item-proto :do-action ()
  37.   (let* ((graph (send self :graph))
  38.          (is-on (send graph :tour-on)))
  39.      (send graph :tour-on (not is-on))))
  40.  
  41. (defmeth tour-mixin :menu-template ()
  42.  (append (call-next-method)
  43.          (list (send tour-item-proto :new self))))
  44.  
  45. (defproto spin-tour-proto () () (list tour-mixin spin-proto))
  46. (send spin-tour-proto :title "Grand Tour")
  47. (send spin-tour-proto :menu-title "Tour")
  48.  
  49. (defun tour-plot (data &rest args &key point-labels)
  50.   (let ((graph (apply #'send spin-tour-proto :new
  51.                       (length data) args)))
  52.     (if point-labels
  53.         (send graph :add-points
  54.               data :point-labels point-labels :draw nil)
  55.         (send graph :add-points data :draw nil))
  56.     (send graph :adjust-to-data :draw nil)
  57.     graph))
  58.  
  59. (defproto hist-tour-proto '(angle) () (list tour-mixin histogram-proto))
  60. (defmeth hist-tour-proto :angle (&optional new)
  61.   (if new (setf (slot-value 'angle) new))
  62.   (slot-value 'angle))
  63. (send hist-tour-proto :angle .1)
  64. (send hist-tour-proto :scale-type 'variable)
  65. (send hist-tour-proto :title "Histogram Tour")
  66. (send hist-tour-proto :menu-title "Tour")
  67. (defun histogram-tour (data &rest args &key point-labels)
  68.   (let ((graph (apply #'send hist-tour-proto :new
  69.                       (length data) :draw nil args)))
  70.     (if point-labels
  71.         (send graph :add-points
  72.               data :point-labels point-labels :draw nil)
  73.         (send graph :add-points data :draw nil))
  74.     (send graph :adjust-to-data :draw nil)
  75.     graph))
  76.